home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / ERROR.C < prev    next >
C/C++ Source or Header  |  1992-02-10  |  8KB  |  302 lines
  1. /* Copyright (C) 1990-1992 Free Software Foundation, Inc.
  2.  
  3.    This program is free software; you can redistribute it and/or modify
  4.    it under the terms of the GNU General Public License as published by
  5.    the Free Software Foundation; either version 1, or (at your option)
  6.    any later version.
  7.  
  8.    This program is distributed in the hope that it will be useful,
  9.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.    GNU General Public License for more details.
  12.  
  13.    You should have received a copy of the GNU General Public License
  14.    along with this program; if not, write to the Free Software
  15.    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  16.  
  17. /* $Header: /scheme/src/microcode/RCS/error.c,v 1.2 1992/02/10 13:10:44 jinx Exp $ */
  18.  
  19. #include <stdio.h>
  20. #include "dstack.h"
  21.  
  22. static PTR
  23. DEFUN (xmalloc, (length), unsigned int length)
  24. {
  25.   extern PTR EXFUN (malloc, (unsigned int length));
  26.   PTR result = (malloc (length));
  27.   if (result == 0)
  28.     {
  29.       fputs ("malloc: memory allocation failed\n", stderr);
  30.       fflush (stderr);
  31.       abort ();
  32.     }
  33.   return (result);
  34. }
  35.  
  36. struct handler_record
  37. {
  38.   struct handler_record * next;
  39.   Tcondition_type type;
  40.   void EXFUN ((*handler), (Tcondition));
  41. };
  42.  
  43. struct restart_record
  44. {
  45.   struct restart_record * next;
  46.   struct condition_restart contents;
  47. };
  48.  
  49. static unsigned long next_condition_type_index;
  50. static struct handler_record * current_handler_record;
  51. static struct restart_record * current_restart_record;
  52.  
  53. void
  54. DEFUN_VOID (initialize_condition_system)
  55. {
  56.   next_condition_type_index = 0;
  57.   current_handler_record = 0;
  58.   current_restart_record = 0;
  59. }
  60.  
  61. Tcondition_type
  62. DEFUN (condition_type_allocate, (name, generalizations, reporter),
  63.        PTR name AND
  64.        Tptrvec generalizations AND
  65.        void EXFUN ((*reporter), (Tcondition condition)))
  66. {
  67.   static Tptrvec EXFUN (generalizations_union, (Tptrvec generalizations));
  68.   Tcondition_type type = (xmalloc (sizeof (struct condition_type)));
  69.   Tptrvec g = (generalizations_union (generalizations));
  70.   ptrvec_adjoin (g, type);
  71.   (CONDITION_TYPE_INDEX (type)) = (next_condition_type_index++);
  72.   (CONDITION_TYPE_NAME (type)) = name;
  73.   (CONDITION_TYPE_GENERALIZATIONS (type)) = g;
  74.   (CONDITION_TYPE_REPORTER (type)) = reporter;
  75.   return (type);
  76. }
  77.  
  78. void
  79. DEFUN (condition_type_deallocate, (type), Tcondition_type type)
  80. {
  81.   ptrvec_deallocate (CONDITION_TYPE_GENERALIZATIONS (type));
  82.   free (type);
  83. }
  84.  
  85. Tcondition
  86. DEFUN (condition_allocate, (type, irritants),
  87.        Tcondition_type type AND
  88.        Tptrvec irritants)
  89. {
  90.   Tcondition condition = (xmalloc (sizeof (struct condition)));
  91.   (CONDITION_TYPE (condition)) = type;
  92.   (CONDITION_IRRITANTS (condition)) = irritants;
  93.   return (condition);
  94. }
  95.  
  96. void
  97. DEFUN (condition_deallocate, (condition), Tcondition condition)
  98. {
  99.   ptrvec_deallocate (CONDITION_IRRITANTS (condition));
  100.   free (condition);
  101. }
  102.  
  103. static Tptrvec
  104. DEFUN (generalizations_union_2, (x, y), Tptrvec x AND Tptrvec y)
  105. {
  106.   PTR * scan_x = (PTRVEC_START (x));
  107.   PTR * end_x = (scan_x + (PTRVEC_LENGTH (x)));
  108.   PTR * scan_y = (PTRVEC_START (y));
  109.   PTR * end_y = (scan_y + (PTRVEC_LENGTH (y)));
  110.   Tptrvec_length length = 0;
  111.   unsigned long ix;
  112.   unsigned long iy;
  113.   Tptrvec result;
  114.   PTR * scan_result;
  115.   while (1)
  116.     {
  117.       if (scan_x == end_x)
  118.     {
  119.       length += (end_y - scan_y);
  120.       break;
  121.     }
  122.       if (scan_y == end_y)
  123.     {
  124.       length += (end_x - scan_x);
  125.       break;
  126.     }
  127.       length += 1;
  128.       ix = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_x)));
  129.       iy = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_y)));
  130.       if (ix <= iy) scan_x += 1;
  131.       if (iy <= ix) scan_y += 1;
  132.     }
  133.   result = (ptrvec_allocate (length));
  134.   scan_result = (PTRVEC_START (result));
  135.   while (1)
  136.     {
  137.       if (scan_x == end_x)
  138.     {
  139.       while (scan_y < end_y) (*scan_result++) = (*scan_y++);
  140.       break;
  141.     }
  142.       if (scan_y == end_y)
  143.     {
  144.       while (scan_x < end_x) (*scan_result++) = (*scan_x++);
  145.       break;
  146.     }
  147.       ix = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_x)));
  148.       iy = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_y)));
  149.       if (ix == iy)
  150.     {
  151.       (*scan_result++) = (*scan_x++);
  152.       scan_y += 1;
  153.     }
  154.       else
  155.     (*scan_result++) = ((ix < iy) ? (*scan_x++) : (*scan_y++));
  156.     }
  157.   return (result);
  158. }
  159.  
  160. static Tptrvec
  161. DEFUN (generalizations_union, (generalizations), Tptrvec generalizations)
  162. {
  163.   Tptrvec_length length = (PTRVEC_LENGTH (generalizations));
  164.   if (length == 0)
  165.     return (ptrvec_allocate (0));
  166.   if (length == 1)
  167.     return (ptrvec_copy (PTRVEC_REF (generalizations, 0)));
  168.   {
  169.     PTR * scan = (PTRVEC_START (generalizations));
  170.     PTR * end = (scan + length);
  171.     Tptrvec result = ((Tptrvec) (*scan++));
  172.     result = (generalizations_union_2 (result, ((Tptrvec) (*scan++))));
  173.     while (scan < end)
  174.       {
  175.     Tptrvec v = (generalizations_union_2 (result, ((Tptrvec) (*scan++))));
  176.     ptrvec_deallocate (result);
  177.     result = v;
  178.       }
  179.     return (result);
  180.   }
  181. }
  182.  
  183. void
  184. DEFUN (condition_handler_bind, (type, handler),
  185.        Tcondition_type type AND
  186.        void EXFUN ((*handler), (Tcondition condition)))
  187. {
  188.   struct handler_record * record =
  189.     (dstack_alloc (sizeof (struct handler_record)));
  190.   (record -> next) = current_handler_record;
  191.   (record -> type) = type;
  192.   (record -> handler) = handler;
  193.   dstack_bind ((¤t_handler_record), record);
  194. }
  195.  
  196. #define GENERALIZATIONS(condition)                    \
  197.   (CONDITION_TYPE_GENERALIZATIONS (CONDITION_TYPE (condition)))
  198.  
  199. void
  200. DEFUN (condition_signal, (condition), Tcondition condition)
  201. {
  202.   Tptrvec generalizations = (GENERALIZATIONS (condition));
  203.   struct handler_record * record = current_handler_record;
  204.   while (record != 0)
  205.     {
  206.       Tcondition_type type = (record -> type);
  207.       if ((type == 0) || (ptrvec_memq (generalizations, type)))
  208.     {
  209.       PTR position = dstack_position;
  210.       dstack_bind ((¤t_handler_record), (record -> next));
  211.       (* (record -> handler)) (condition);
  212.       dstack_set_position (position);
  213.     }
  214.       record = (record -> next);
  215.     }
  216. }
  217.  
  218. void
  219. DEFUN (condition_restart_bind, (name, type, procedure),
  220.        PTR name AND
  221.        Tcondition_type type AND
  222.        void EXFUN ((*procedure), (PTR argument)))
  223. {
  224.   struct restart_record * record =
  225.     (dstack_alloc (sizeof (struct restart_record)));
  226.   (record -> next) = current_restart_record;
  227.   (record -> contents . name) = name;
  228.   (record -> contents . type) = type;
  229.   (record -> contents . procedure) = procedure;
  230.   dstack_bind ((¤t_restart_record), record);
  231. }
  232.  
  233. Tcondition_restart
  234. DEFUN (condition_restart_find, (name, condition),
  235.        PTR name AND
  236.        Tcondition condition)
  237. {
  238.   struct restart_record * record = current_restart_record;
  239.   if (condition == 0)
  240.     while (record != 0)
  241.       {
  242.     if ((record -> contents . name) == name)
  243.       return (& (record -> contents));
  244.     record = (record -> next);
  245.       }
  246.   else
  247.     {
  248.       Tptrvec generalizations = (GENERALIZATIONS (condition));
  249.       while (record != 0)
  250.     {
  251.       if (((record -> contents . name) == name) &&
  252.           (ptrvec_memq (generalizations, (record -> contents . type))))
  253.         return (& (record -> contents));
  254.       record = (record -> next);
  255.     }
  256.     }
  257.   return (0);
  258. }
  259.  
  260. Tptrvec
  261. DEFUN (condition_restarts, (condition), Tcondition condition)
  262. {
  263.   struct restart_record * record = current_restart_record;
  264.   Tptrvec_length length = 0;
  265.   Tptrvec generalizations;
  266.   Tptrvec result;
  267.   PTR * scan_result;
  268.   if (condition == 0)
  269.     while (record != 0)
  270.       {
  271.     length += 1;
  272.     record = (record -> next);
  273.       }
  274.   else
  275.     {
  276.       generalizations = (GENERALIZATIONS (condition));
  277.       while (record != 0)
  278.     {
  279.       if (ptrvec_memq (generalizations, (record -> contents . type)))
  280.         length += 1;
  281.       record = (record -> next);
  282.     }
  283.     }
  284.   result = (ptrvec_allocate (length));
  285.   scan_result = (PTRVEC_START (result));
  286.   record = current_restart_record;
  287.   if (condition == 0)
  288.     while (record != 0)
  289.       {
  290.     (*scan_result++) = (& (record -> contents));
  291.     record = (record -> next);
  292.       }
  293.   else
  294.     while (record != 0)
  295.       {
  296.     if (ptrvec_memq (generalizations, (record -> contents . type)))
  297.       (*scan_result++) = (& (record -> contents));
  298.     record = (record -> next);
  299.       }
  300.   return (result);
  301. }
  302.